home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / powerlogo-1.4 / utilities / turtle-shell < prev    next >
Encoding:
Text File  |  1996-07-16  |  34.1 KB  |  1,121 lines
  1.  
  2. ;  ***************************************************************
  3. ;  ***   Turtle Shell
  4. ;  ***************************************************************
  5.  
  6. if buriedp "turtle-names [ unbury "turtle-names ] [ ]
  7.  
  8. make "turtle-names [
  9.    turtle-names
  10.    turtle endturtle tg-menu
  11.    tg-menu-demon tg-mouse-demon tg-close-demon
  12.    color-window color-pen-box click-color-window mode
  13.    mouse-window click-mouse-window mouse-tool addmouse
  14.    mouse-tool-draw mouse-tool-brush mouse-tool-oneline mouse-tool-linkline
  15.    mouse-tool-ellipse mouse-tool-position mouse-tool-block
  16.    mouse-tool-record while-mouse-down
  17.    action-window click-action-window action-tool addaction
  18.    poly circle playback set-record record
  19.    palette-window pattern
  20.    setghosts setchecks movechecks movecheck
  21.    reset-menus attach-menus drawbox
  22.    ct cs fs ts ss ]
  23.  
  24. unbury :turtle-names
  25.  
  26. make "tg-window @1
  27. make "tg-mouse-window @1
  28. make "tg-color-window @1
  29. make "tg-palette-window @1
  30. make "tg-action-window @1
  31. make "size 1
  32.  
  33. pprop "startup-data "keepers se  [  tg-data
  34.                                     tg-window
  35.                                     tg-mouse-window
  36.                                     tg-color-window
  37.                                     tg-palette-window
  38.                                     tg-action-window
  39.                                     tg-screen
  40.                                     tg-turtle
  41.                                     tg-mouse-tool
  42.                                     tg-color-pen
  43.                                     size
  44.                                  ] gprop "startup-data "keepers
  45.  
  46.  
  47. pprop "tg-data "hogmem 300000
  48.  
  49.  
  50. ; *********************************************************************
  51. ;  turtle         ( view-modes bit-planes )
  52. ;     Prepare screen, window, and turtle for turtle graphics.
  53.  
  54. make "turtle [
  55.    procedure [ [ ] [ :t-v :t-d ] [ :t-vm :t-cl :t-i :t-sx :t-sy :t-w :t-h :t-on ] ]
  56.    if numberp :t-v [ ] [ make "t-v 3 ]
  57.    if numberp :t-d [ ] [ make "t-d 3 ]
  58.    make "t-on if = 3 :t-v
  59.                [ [ color-window mouse-window action-window ] ]
  60.                [ [ ] ]
  61.    make "t-cl gprop "tg-data "color-list
  62.    if emptyp :t-cl
  63.    [  make "t-i 19
  64.       repeat 3 [ make "t-cl fput rgb @0 :t-i :t-cl dec "t-i ]
  65.       make "t-cl ( se
  66.          [  [  0  0  0 ] [ 14 14 14 ] [ 7 0 7 ] [ 0 15 0 ]
  67.             [ 15 0 0 ] [ 0 0 15 ] [ 11 4 0 ] [ 15 15 0 ]
  68.             [ 6 2 0 ] [ 15 11 8 ] [ 1 14 15 ] [ 14 11 0 ]
  69.             [ 5 5 15 ] [ 9 2 15 ] [ 0 6 3 ] [ 15 0 15 ]
  70.             [ 14 8 5 ] ]
  71.          :t-cl
  72.          [  [ 10 0 4 ] [ 10 2 5 ] [ 9 4 6 ] [ 9 6 7 ]
  73.             [ 11 9 10 ] [ 12 12 12 ] [ 10 10 10 ] [ 8 8 8 ]
  74.             [ 7 7 7 ] [ 5 5 5 ] [ 3 3 3 ] [ 15 15 15 ] ] )
  75.       pprop "tg-data "color-list :t-cl ] [ ]
  76.    if namep "tg-screen
  77.    [  if memberp :tg-screen screenlist
  78.       [  make "t-cl [ ]
  79.          make "t-i 31
  80.          repeat 32 [ make "t-cl fput rgb :tg-screen :t-i :t-cl dec "t-i ]
  81.          pprop "tg-data "color-list :t-cl
  82.          make "t-on ( se  if memberp :tg-color-window windowlist
  83.                              [ [ color-window ] ] [ [ ] ]
  84.                           if memberp :tg-mouse-window windowlist
  85.                              [ [ mouse-window ] ] [ [ ] ]
  86.                           if memberp :tg-action-window windowlist
  87.                              [ [ action-window ] ] [ [ ] ]
  88.                           if memberp :tg-palette-window windowlist
  89.                              [ [ palette-window ] ] [ [ ] ] )
  90.          closescreen :tg-screen ] [ ] ] [ ]
  91.    pprop "tg-data "modes :t-v
  92.    pprop "tg-data "depth :t-d
  93.  
  94.  
  95. ; ***  changed for AGA no more extra half bright ***
  96. ;   make "t-vm if = :t-d 6 [ + 4 :t-v ] [ :t-v ]
  97.    make "t-vm :t-v
  98.  
  99.  
  100.    recycle
  101.    make "tg-screen ( openscreen :t-vm :t-d )
  102.    make "tg-window ( openwindow :tg-screen 64 [ ] )
  103.    make "tg-turtle openturtle :tg-window
  104.    putprop "startup-data "screen :tg-screen
  105.    make "t-i 0
  106.    repeat 32
  107.    [  setrgb :tg-screen :t-i first :t-cl
  108.       make "t-cl bf :t-cl
  109.       inc "t-i ]
  110.    make "t-w peek -2 psum :tg-screen 12
  111.    make "t-h peek -2 psum :tg-screen 14
  112.    pprop "tg-data "width :t-w
  113.    pprop "tg-data "height :t-h
  114.    make "t-sx if <= 640 :t-w [ - :t-w 292 ] [ :t-w ]
  115.    make "t-sy if <= 400 :t-h [ 54 ] [ 46 ]
  116.    ( movecommand :tg-screen 0 - :t-h :t-sy
  117.                             :t-sx :t-sy )
  118.    pprop "tg-data "drawmode 1
  119.    pprop "tg-data "pattern 1
  120.    pprop "tg-data "mouse-tool-number 1
  121.    whenmenu [ tg-menu-demon getmenu ]
  122.    whenmouse [ tg-mouse-demon ]
  123.    whenclose [ tg-close-demon getclose ]
  124.    attach-menus @0
  125.    attach-menus :tg-window
  126.    mode 3
  127.    pattern 1
  128.    mouse-tool 1
  129.    run :t-on ]
  130.  
  131.  
  132. make "endturtle [
  133.    procedure [ [ ] [ ] [ :t-cl :t-i ] ]
  134.    if namep "tg-screen
  135.    [  if memberp :tg-screen screenlist
  136.       [  closewindow :tg-window
  137.          ( movecommand @0 0 11 550 189 )
  138.          make "t-cl [ ]
  139.          make "t-i 31
  140.          repeat 32 [ make "t-cl fput rgb :tg-screen :t-i :t-cl dec "t-i ]
  141.          pprop "tg-data "color-list :t-cl
  142.          closescreen :tg-screen ] [ ] ] [ ]
  143.    pprop "startup-data "screen @0
  144.    whenmenu [ comm-menu-demon getmenu ]
  145.    setmenu @0 :comm-menu
  146.    whenmouse [ ]
  147.    whenclose [ ] ]
  148.  
  149.  
  150. ; *********************************************************************
  151. ; *** Menu data
  152. ; *********************************************************************
  153.  
  154. make "tg-menu [
  155.  
  156.    \ LOGO\ 
  157.       [ \ Load ]
  158.       [ \ Save ]
  159.       [ \ Edit E ]
  160.       [ \ Edit\ File ]
  161.       [ \ Turtle\ Off ]
  162.       [ \ Interrupt ]
  163.       [ \ Top\ Level G ]
  164.       [ \ Quit ]
  165.  
  166.    \ Picture\  
  167.       [ \ Load ]
  168.       [ \ Save ]
  169.       [ \ Pattern
  170.          [ \ \ xxxxxxxxxxxxxxxx ]
  171.          [ \ \ xxxxxxxx-------- ]
  172.          [ \ \ xxxx----xxxx---- ]
  173.          [ \ \ xx--xx--xx--xx-- ]
  174.          [ \ \ x-x-x-x-x-x-x-x- ]
  175.          [ \ \ x---x---x---x--- ]
  176.          [ \ \ x-------x------- ]
  177.          [ \ \ -xxx-xxx-xxx-xxx ]
  178.          [ \ \ -xxxxxxx-xxxxxxx ]
  179.          [ \ \ x--------------- ]
  180.          [ \ \ xx-------------- ]
  181.          [ \ \ xxxx------------ ]
  182.          [ \ \ xxxxxxxxxxxx---- ]
  183.          [ \ \ -------xxx---xxx ]
  184.          [ \ \ xxxxxxx---xxx--- ] ]
  185.       [ \ Mouse ]
  186.       [ \ Action ]
  187.       [ \ Pen
  188.          [ \ \ Up U ]
  189.          [ \ \ Down D ]
  190.          [ \ \ JAM1 ]
  191.          [ \ \ JAM2 ]
  192.          [ \ \ COMP ] ]
  193.       [ \ Windows
  194.          [ \ Full F ]
  195.          [ \ Split S ]
  196.          [ \ Text T ]
  197.          [ \ Palette P ]
  198.          [ \ Pen\ Color C ]
  199.          [ \ Mouse M ]
  200.          [ \ Action A ] ]
  201.       [ \ Colors
  202.          [ \ \ 2 ]
  203.          [ \ \ 4 ]
  204.          [ \ \ 8 ]
  205.          [ \ \ 16 ]
  206.          [ \ \ 32 ]
  207.          [ \ \ 64 ]
  208. ;  ***   128 & 256 added for AGA   ***
  209.          [ \ \ 128 ]
  210.          [ \ \ 256 ] ]
  211.       [ \ Size
  212.          [ \ \ 320x200 ]
  213.          [ \ \ 640x200 ]
  214.          [ \ \ 320x400 ]
  215.          [ \ \ 640x400 ] ] ]
  216.  
  217.  
  218. ; *********************************************************************
  219. ; *** Demons
  220. ; *********************************************************************
  221.  
  222.  
  223. make "tg-menu-demon [
  224.    procedure [ [ :tmd-menu-data ] [ ]
  225.                [ :tmd-menu-item :tmd-menu-subitem :tmd-menu-temp ] ]
  226.    make "tmd-menu-item item 3 :tmd-menu-data
  227.    make "tmd-menu-subitem item 4 :tmd-menu-data
  228.  
  229.    switch item 2 :tmd-menu-data
  230.    [
  231.       [  switch :tmd-menu-item
  232.          [
  233.             [  make "tmd-menu-temp ( filerequest "Load\ File\ \ -\  )
  234.                ( intuition 6 :tg-screen )
  235.                if emptyp :tmd-menu-temp [ ]
  236.                   [ load :tmd-menu-temp ] ]
  237.             [  make "tmd-menu-temp ( filerequest "Save\ File\ \ -\  )
  238.                ( intuition 6 :tg-screen )
  239.                if emptyp :tmd-menu-temp [ ]
  240.                [  save  :tmd-menu-temp
  241.                         remove-quick   se    gprop "startup-data "keepers
  242.                                              [  s-item
  243.                                                 s-list
  244.                                                 tmd-menu-data
  245.                                                 tmd-menu-item
  246.                                                 tmd-menu-subitem
  247.                                                 tmd-menu-temp ]
  248.                                        namelist ] ]
  249.             [ edit ]
  250.             [ edf [ ] ]
  251.             [ endturtle type "? ]
  252.             [ system 11 interrupt ]
  253.             [ toplevel ]
  254.             [ clean-quit ] ] ]
  255.  
  256.       [  switch :tmd-menu-item
  257.          [
  258.             [  make "tmd-menu-temp ( filerequest "Load\ Picture\ \ -\  )
  259.                ( intuition 6 :tg-screen )
  260.                if emptyp :tmd-menu-temp [ ]
  261.                [  ( intuition 11 :tg-window )
  262.                   wait 0.1
  263.                   loadimage :tg-window :tmd-menu-temp ] ]
  264.  
  265.             [  make "tmd-menu-temp ( filerequest "Save\ Picture\ \ -\  )
  266.                ( intuition 6 :tg-screen )
  267.                if emptyp :tmd-menu-temp [ ]
  268.                [  ( intuition 11 :tg-window )
  269.                   wait 0.1
  270.                   saveimage :tg-window :tmd-menu-temp
  271.                   ( saveicon :tmd-menu-temp " [ FILETYPE=ilbm ] ) ] ]
  272.  
  273.             [ pattern :tmd-menu-subitem ]
  274.  
  275.             [ mouse-tool :tmd-menu-subitem ]
  276.  
  277.             [ action-tool :tmd-menu-subitem ]
  278.  
  279.             [ mode :tmd-menu-subitem ]
  280.  
  281.             [  switch :tmd-menu-subitem
  282.                [  [ fs ]
  283.                   [ ss ]
  284.                   [ ts ]
  285.                   [ palette-window ]
  286.                   [ color-window ]
  287.                   [ mouse-window ]
  288.                   [ action-window ] ] ]
  289.  
  290.             [  ( turtle gprop "tg-data "modes :tmd-menu-subitem )
  291.                type "? ]
  292.  
  293.             [  ( turtle - :tmd-menu-subitem 1 gprop "tg-data "depth )
  294.                type "? ]
  295.          ]
  296.       ]
  297.    ]
  298. ]
  299.  
  300.  
  301. make "tg-mouse-demon [
  302.    procedure [ [ ] [ ] [ :tmd-md :tmd-window :x :y :tmd-td ] ]
  303.    dowhile [ make "tmd-md getmouse ] [ mousep ]
  304.    make "tmd-window first :tmd-md
  305.    make "x item 2 :tmd-md
  306.    make "y item 3 :tmd-md
  307.    cond
  308.    [  [ = :tg-window :tmd-window ]
  309.       [  make "tmd-td downp :tg-turtle
  310.          pu
  311.          run :tg-mouse-tool
  312.          if :tmd-td [ pd ] [ ] ]
  313.       [ = :tg-color-window :tmd-window ]
  314.          [ click-color-window :x :y ]
  315.       [ = :tg-mouse-window :tmd-window ]
  316.          [ click-mouse-window :x :y ]
  317.       [ = :tg-action-window :tmd-window ]
  318.          [ click-action-window :x :y ]
  319.    ]
  320. ]
  321.  
  322.  
  323. make "tg-close-demon [
  324.    procedure [ [ :tcd-window ] ]
  325.    if memberp :tcd-window windowlist [ closewindow :tcd-window ] [ ] ]
  326.  
  327.  
  328. ; *********************************************************************
  329. ; *** Pen Color
  330. ; *********************************************************************
  331.  
  332.  
  333. make "color-window [
  334.    procedure [ [ ] [ ] [ :cw-sx :cw-sy :cw-c :cw-x :cw-y
  335.                          :cw-x2 :cw-y2 :cw-i ] ]
  336.    if memberp :tg-color-window windowlist
  337.    [  ( intuition 11 :tg-color-window )
  338.       stop ] [ ]
  339.  
  340. ;  ***  AGA  ***
  341. ;                                            2  4  8  8 16 16 32 32
  342.    make "cw-sx item gprop "tg-data "depth [ 96 48 24 24 12 12  6  6 ]
  343.    make "cw-sy item gprop "tg-data "depth [ 32 32 32 16 16  8  8  4 ]
  344. ;                                            1  1  1  2  2  4  4  8
  345.  
  346. ;   make "cw-sy item gprop "tg-data "depth [ 24 24 24 12 12  6  6  3 ]
  347.  
  348.  
  349.  
  350.    make "cw-x -   gprop "tg-data "width
  351.                if < 600 gprop "tg-data "width [ 290 ] [ 200 ]
  352.  
  353.  
  354.    make "cw-y - gprop "tg-data "height 73 ; *** AGA was 65
  355.    make "tg-color-window ( openwindow  :tg-screen
  356.                                        7
  357.                                        [ Pen Color ]
  358.                                        :cw-x :cw-y
  359.                                        200 73 ) ; *** AGA was 65
  360.    attach-menus :tg-color-window
  361.  
  362.    setpen :tg-color-window 1
  363.    move :tg-color-window 17 19
  364.    text :tg-color-window [ PU ]
  365.    move :tg-color-window 55 19
  366.    text :tg-color-window [ PD ]
  367.    move :tg-color-window 85 19
  368.    text :tg-color-window [ JAM1 ]
  369.    move :tg-color-window 123 19
  370.    text :tg-color-window [ JAM2 ]
  371.    move :tg-color-window 161 19
  372.    text :tg-color-window [ COMP ]
  373.    move :tg-color-window 20 33
  374.    text :tg-color-window [ FG ]
  375.    move :tg-color-window 80 33
  376.    text :tg-color-window [ BG ]
  377.    move :tg-color-window 140 33
  378.    text :tg-color-window [ AO ]
  379.  
  380.    setpen :tg-color-window ( pen :tg-window 0 )
  381.    rectfill :tg-color-window 40 25 60 35
  382.    setpen :tg-color-window ( pen :tg-window 1 )
  383.    rectfill :tg-color-window 100 25 120 35
  384.    setpen :tg-color-window ( pen :tg-window 2 )
  385.    rectfill :tg-color-window 160 25 180 35
  386.  
  387.    make "cw-i 0
  388.    make "cw-y 39
  389.    make "cw-y2 + 38 :cw-sy
  390.    while [ < :cw-y 70 ] ; *** AGA was 62
  391.    [  make "cw-x 4
  392.       make "cw-x2 + 3 :cw-sx
  393.       while [ < :cw-x 192 ]
  394.       [  setpen :tg-color-window :cw-i
  395.          rectfill :tg-color-window :cw-x :cw-y :cw-x2 :cw-y2
  396.          inc "cw-i
  397.          make "cw-x + :cw-sx :cw-x
  398.          make "cw-x2 + :cw-sx :cw-x2 ]
  399.       make "cw-y + :cw-sy :cw-y
  400.       make "cw-y2 + :cw-sy :cw-y2 ]
  401.  
  402.    setpen :tg-color-window 30
  403.    drawbox :tg-color-window 5 11 36 10
  404.    drawbox :tg-color-window 43 11 36 10
  405.    drawbox :tg-color-window 81 11 36 10
  406.    drawbox :tg-color-window 119 11 36 10
  407.    drawbox :tg-color-window 157 11 36 10
  408.  
  409.    drawbox :tg-color-window 15 23 50 14
  410.    drawbox :tg-color-window 75 23 50 14
  411.    drawbox :tg-color-window 135 23 50 14
  412.  
  413.    setpen :tg-color-window 31
  414.    drawbox :tg-color-window + 5 if downp :tg-turtle [ 38 ] [ 0 ] 11 36 10
  415.    drawbox :tg-color-window + 43 * 38 gprop "tg-data "drawmode 11 36 10
  416.  
  417.    make "tg-color-pen 0
  418.    color-pen-box 0
  419. ]
  420.  
  421.  
  422. make "color-pen-box [
  423.    procedure [ [ :cpb-c ] [ ] [ :cpb-x ] ]
  424.    setpen :tg-color-window 30
  425.    make "cpb-x + 15 * 60 :tg-color-pen
  426.    drawbox :tg-color-window :cpb-x 23 50 14
  427.    setpen :tg-color-window 31
  428.    make "cpb-x + 15 * 60 :cpb-c
  429.    drawbox :tg-color-window :cpb-x 23 50 14
  430.    make "tg-color-pen :cpb-c ]
  431.  
  432.  
  433. make "click-color-window [
  434.    procedure [ [ :ccw-x :ccw-y ] [ ] [ :ccw-c ] ]
  435.    cond
  436.    [  [ >>= 24 36 :ccw-y ]
  437.       [  cond
  438.          [  [ >>= 15 65 :ccw-x ] [ color-pen-box 0 ]
  439.             [ >>= 75 125 :ccw-x ] [ color-pen-box 1 ]
  440.             [ >>= 135 185 :ccw-x ] [ color-pen-box 2 ] ] ]
  441. ;           ***    62 AGA ***    
  442.       [ and >>= 39 70 :ccw-y >>= 4 195 :ccw-x ]
  443.       [  make "ccw-c readpixel :tg-color-window :ccw-x :ccw-y
  444.          ( setpen :tg-window :ccw-c :tg-color-pen )
  445.          if = 2 :tg-color-pen [ ] [ settpn :ccw-c :tg-color-pen ]
  446.          setpen :tg-color-window :ccw-c
  447.          switch + 1 :tg-color-pen
  448.          [  [ rectfill :tg-color-window 40 25 60 35 ]
  449.             [ rectfill :tg-color-window 100 25 120 35 ]
  450.             [ rectfill :tg-color-window 160 25 180 35 ] ] ]
  451.       [ >>= 11 21 :ccw-y ]
  452.       [  cond
  453.          [  [ >>= 5 41 :ccw-x ] [ mode 1 ]
  454.             [ >>= 43 79 :ccw-x ] [ mode 2 ]
  455.             [ >>= 81 117 :ccw-x ] [ mode 3 ]
  456.             [ >>= 119 155 :ccw-x ] [ mode 4 ]
  457.             [ >>= 157 193 :ccw-x ] [ mode 5 ] ] ] ] ]
  458.  
  459.  
  460. make "mode [
  461.    procedure [ [ :m-item ] [ ] [ :m-x ] ]
  462.    if = :m-item 1
  463.    [  pu
  464.       movechecks 2 6 2 1
  465.       if memberp :tg-color-window windowlist
  466.       [  setpen :tg-color-window 30
  467.          drawbox :tg-color-window 43 11 36 10
  468.          setpen :tg-color-window 31
  469.          drawbox :tg-color-window 5 11 36 10 ] [ ]
  470.       stop ] [ ]
  471.    if = :m-item 2
  472.    [  pd
  473.       movechecks 2 6 1 2
  474.       if memberp :tg-color-window windowlist
  475.       [  setpen :tg-color-window 30
  476.          drawbox :tg-color-window 5 11 36 10
  477.          setpen :tg-color-window 31
  478.          drawbox :tg-color-window 43 11 36 10 ] [ ]
  479.       stop ] [ ]
  480.    if memberp :tg-color-window windowlist
  481.    [  setpen :tg-color-window 30
  482.       make "m-x + 43 * 38 gprop "tg-data "drawmode 
  483.       drawbox :tg-color-window :m-x 11 36 10
  484.       setpen :tg-color-window 31
  485.       make "m-x + -33 * 38 :m-item 
  486.       drawbox :tg-color-window :m-x 11 36 10 ] [ ]
  487.    settdm - :m-item 3
  488.    setdrmode :tg-window - :m-item 3
  489.    movechecks 2 6 + 2 gprop "tg-data "drawmode :m-item
  490.    pprop "tg-data "drawmode - :m-item 2 ]
  491.  
  492.  
  493. ; *********************************************************************
  494. ; *** Mouse Tools
  495. ; *********************************************************************
  496.  
  497.  
  498. make "mouse-window [
  499.    procedure [ [ ] [ ] [ :mw-tool-names :mw-sy :mw-c :mw-x :mw-y :mw-i ] ]
  500.    if memberp :tg-mouse-window windowlist
  501.    [  ( intuition 11 :tg-mouse-window )
  502.       stop ] [ ]
  503.    make "mw-tool-names gprop "tg-data "mouse-tool-names
  504.    make "mw-c count :mw-tool-names
  505.    make "mw-sy + 17 * 10 :mw-c
  506.    make "mw-x - gprop "tg-data "width 88
  507.    make "mw-y - gprop "tg-data "height :mw-sy
  508.    make "tg-mouse-window ( openwindow  :tg-screen
  509.                                        7
  510.                                        [ Mouse ]
  511.                                        :mw-x :mw-y
  512.                                        88 :mw-sy )
  513.    attach-menus :tg-mouse-window
  514.  
  515.    setpen :tg-mouse-window 1
  516.    make "mw-i 20
  517.    repeat :mw-c
  518.    [  move :tg-mouse-window 12 :mw-i
  519.       text :tg-mouse-window first :mw-tool-names
  520.       make "mw-tool-names bf :mw-tool-names
  521.       make "mw-i + 10 :mw-i ]
  522.  
  523.    setpen :tg-mouse-window 30
  524.    make "mw-i 12
  525.    repeat :mw-c
  526.    [  drawbox :tg-mouse-window 7 :mw-i 73 10
  527.       make "mw-i + 10 :mw-i ]
  528.  
  529.    setpen :tg-mouse-window 31
  530.    drawbox     :tg-mouse-window
  531.                7
  532.                + 2 * 10 gprop "tg-data "mouse-tool-number
  533.                73
  534.                10 ]
  535.  
  536.  
  537. make "click-mouse-window [
  538.    procedure [ [ :cmw-x :cmw-y ] [ ] [ :cmw-tc :cmw-tn ] ]
  539.    make "cmw-tc count gprop "tg-data "mouse-tools
  540.    make "cmw-tn int / - :cmw-y 4 10
  541.    if > :cmw-tn :cmw-tc
  542.    [  make "cmw-tn :cmw-tc ]
  543.    [  if < :cmw-tn 1 [ make "cmw-tn 1 ] [ ] ]
  544.    mouse-tool :cmw-tn ]
  545.  
  546.  
  547. make "mouse-tool [
  548.    procedure [ [ :mt-item ] ]
  549.    if memberp :tg-mouse-window windowlist
  550.    [  setpen :tg-mouse-window 30
  551.       drawbox :tg-mouse-window 7 + 2 * 10 gprop "tg-data "mouse-tool-number 73 10
  552.       setpen :tg-mouse-window 31
  553.       drawbox :tg-mouse-window 7 + 2 * 10 :mt-item 73 10 ] [ ]
  554.    movechecks 2 4 gprop "tg-data "mouse-tool-number :mt-item
  555.    pprop "tg-data "mouse-tool-number :mt-item
  556.    make "tg-mouse-tool item :mt-item gprop "tg-data "mouse-tools ]
  557.  
  558.  
  559. make "addmouse [
  560.    procedure [ [ :am-tool-name :am-tool ] [ ]
  561.                [ :am-tool-names :am-tools :am-open ] ]
  562.    make "am-tool-names gprop "tg-data "mouse-tool-names
  563.    make "am-tools gprop "tg-data "mouse-tools
  564.    if memberp :am-tool-name :am-tool-names [ ]
  565.    [  make "am-open false
  566.       if namep "tg-mouse-window
  567.       [  if memberp :tg-mouse-window windowlist
  568.          [  make "am-open true
  569.             closewindow :tg-mouse-window ] [ ] ] [ ]
  570.       pprop "tg-data "mouse-tool-names lput :am-tool-name :am-tool-names
  571.       pprop "tg-data "mouse-tools lput :am-tool :am-tools
  572.       repitem     14
  573.                   :tg-menu
  574.                   lput     se    [ ]
  575.                                  word  "\ \  
  576.                                        :am-tool-name
  577.                            item 14 :tg-menu
  578.       if memberp :tg-window windowlist [ reset-menus ] [ ]
  579.       if :am-open [ mouse-window ] [ ] ] ]
  580.  
  581.  
  582. make "mouse-tool-draw [
  583.    procedure [ [ :x :y ] [ ] [ :mtd-md ] ]
  584.    move :tg-window :x :y
  585.    while [  make "mtd-md mouse :tg-window
  586.             = 1 item 3 :mtd-md ]
  587.    [  draw :tg-window first :mtd-md item 2 :mtd-md ]
  588.    settpos wtpos :tg-turtle ]
  589.  
  590. addmouse "Draw [ mouse-tool-draw :x :y ]
  591.  
  592.  
  593. make "mouse-tool-brush [
  594.    procedure [ [ :mtb-size :x1 :y1 ] [ ] [ :x2 :y2 :x3 :y3 :mtb-md ] ]
  595.    make "x2 :x1
  596.    make "y2 :y1
  597.    rectfill :tg-window  - :x2 :mtb-size - :y2 :mtb-size 
  598.                         + :x2 :mtb-size + :y2 :mtb-size
  599.    while [  make "mtb-md mouse :tg-window
  600.             = 1 item 3 :mtb-md ]
  601.    [  make "x3 item 1 :mtb-md
  602.       make "y3 item 2 :mtb-md
  603.       if and = :x2 :x3 = :y2 :y3 [ ]
  604.       [  make "x2 :x3
  605.          make "y2 :y3
  606.          rectfill :tg-window  - :x2 :mtb-size - :y2 :mtb-size 
  607.                               + :x2 :mtb-size + :y2 :mtb-size ] ]
  608.    move :tg-window :x2 :y2
  609.    settpos wtpos :tg-turtle ]
  610.  
  611. ; addmouse "Brush\ 3 [ mouse-tool-brush 1 :x :y ]
  612. ; addmouse "Brush\ 5 [ mouse-tool-brush 2 :x :y ]
  613. addmouse "Brush\ 7 [ mouse-tool-brush 3 :x :y ]
  614.  
  615.  
  616. make "mouse-tool-linkline [
  617.    procedure [ [ :x :y ] ]
  618.    move :tg-window :x :y
  619.    pd
  620.    settpos wtpos :tg-turtle
  621.    pu ]
  622.  
  623. addmouse "LinkLine [ mouse-tool-linkline :x :y ]
  624.  
  625.  
  626. make "mouse-tool-oneline [
  627.    procedure [ [ :x :y ] ]
  628.    while-mouse-down :x :y
  629.    [  setdrmode :tg-window 2 ]
  630.    [  move :tg-window :x2 :y2
  631.       draw :tg-window :x1 :y1 ]
  632.    [  mode + 2 gprop "tg-data "drawmode
  633.       settpos wtpos :tg-turtle
  634.       move :tg-window :x2 :y2
  635.       pd
  636.       settpos wtpos :tg-turtle
  637.       pu ] ]
  638.  
  639. addmouse "OneLine [ mouse-tool-oneline :x :y ]
  640.  
  641.  
  642. make "mouse-tool-ellipse [
  643.    procedure [ [ :x :y ] ]
  644.    while-mouse-down :x :y
  645.    [  setdrmode :tg-window 2 ]
  646.    [  ellipse :tg-window :x1 :y1 abs - :x1 :x2 abs - :y1 :y2 ]
  647.    [  mode + 2 gprop "tg-data "drawmode
  648.       ellipse :tg-window :x1 :y1 abs - :x1 :x2 abs - :y1 :y2
  649.       move :tg-window :x1 :y1
  650.       settpos wtpos :tg-turtle ] ]
  651.  
  652. addmouse "Ellipse [ mouse-tool-ellipse :x :y ]
  653.  
  654.  
  655. make "mouse-tool-block [
  656.    procedure [ [ :x :y ] ]
  657.    while-mouse-down :x :y
  658.    [  setdrmode :tg-window 2 ]
  659.    [  if > :x1 :x2 [ make "x1 :x2 ] [ ]
  660.       if > :y1 :y2 [ make "y1 :y2 ] [ ]
  661.       drawbox :tg-window :x1 :y1 - :x2 :x1 - :y2 :y1 ]
  662.    [  setdrmode :tg-window 0
  663.       rectfill :tg-window :x1 :y1 :x2 :y2
  664.       mode + 2 gprop "tg-data "drawmode
  665.       move :tg-window :x1 :y1
  666.       settpos wtpos :tg-turtle ] ]
  667.  
  668. addmouse "Block [ mouse-tool-block :x :y ]
  669.  
  670.  
  671. addmouse "Flood\ PC [   floodpc :tg-window :x :y
  672.                         move :tg-window :x :y
  673.                         settpos wtpos :tg-turtle ]
  674.  
  675. addmouse "Flood\ OL [   floodol :tg-window :x :y
  676.                         move :tg-window :x :y
  677.                         settpos wtpos :tg-turtle ]
  678.  
  679.  
  680. make "mouse-tool-position [
  681.    procedure [ [ :x :y ] ]
  682.    while-mouse-down :x :y
  683.    [  setdrmode :tg-window 2 ]
  684.    [  move :tg-window :x2 :y2
  685.       draw :tg-window :x1 :y1 ]
  686.    [  settpos wtpos :tg-turtle
  687.       make "x3 first wtpos :tg-turtle
  688.       make "y3 first bf wtpos :tg-turtle
  689.       move :tg-window :x2 :y2
  690.       make "x3 - :x3 first wtpos :tg-turtle
  691.       make "y3 - :y3 first bf wtpos :tg-turtle
  692.       seth toward wtpos :tg-turtle :tg-turtle
  693.       move :tg-window :x1 :y1
  694.       make "size sqrt + * :x3 :x3 * :y3 :y3
  695.       mode + 2 gprop "tg-data "drawmode ] ]
  696.  
  697. addmouse "Position [ mouse-tool-position :x :y ]
  698.  
  699.  
  700. make "set-record [
  701.    procedure [ [ :sr-rec ] ]
  702.    pprop "tg-data "mouse-record :sr-rec ]
  703.  
  704. make "mouse-tool-record [
  705.    procedure [ [ :x1 :y1 ] [ ] [ :mtr-rec :x2 :y2 :x3 :y3 :mtr-md ] ]
  706.    make "mtr-rec fput :size :mtr-rec
  707.    make "mtr-rec fput heading :tg-turtle :mtr-rec
  708.    make "mtr-rec fput wtpos :tg-turtle :mtr-rec
  709.    move :tg-window :x1 :y1
  710.    make "mtr-rec fput wtpos :tg-turtle :mtr-rec
  711.    make "x2 :x1
  712.    make "y2 :y1
  713.    while [  make "mtr-md mouse :tg-window
  714.             = 1 item 3 :mtr-md ]
  715.    [  make "x3 item 1 :mtr-md
  716.       make "y3 item 2 :mtr-md
  717.       if and = :x2 :x3 = :y2 :y3 [ ]
  718.       [  make "x2 :x3
  719.          make "y2 :y3
  720.          draw :tg-window :x2 :y2
  721.          make "mtr-rec fput wtpos :tg-turtle :mtr-rec ] ]
  722.    move :tg-window first twpos :tg-turtle item 2 twpos :tg-turtle
  723.    set-record :mtr-rec ]
  724.  
  725. addmouse "Record [ mouse-tool-record :x :y ]
  726.  
  727.  
  728. make "while-mouse-down [
  729.    procedure [ [ :x1 :y1 :wmd-prep :wmd-rough :wmd-fine ] [ ]
  730.                [ :x2 :y2 :x3 :y3 :wmd-md ] ]
  731.    run :wmd-prep
  732.    make "x2 :x1
  733.    make "y2 :y1
  734.    run :wmd-rough
  735.    while [  make "wmd-md mouse :tg-window
  736.             = 1 item 3 :wmd-md ]
  737.    [  make "x3 item 1 :wmd-md
  738.       make "y3 item 2 :wmd-md
  739.       if and = :x2 :x3 = :y2 :y3 [ ]
  740.       [  run :wmd-rough
  741.          make "x2 :x3
  742.          make "y2 :y3
  743.          run :wmd-rough ] ]
  744.    run :wmd-rough
  745.    run :wmd-fine ]
  746.  
  747.  
  748. ; *********************************************************************
  749. ; *** Action Tools
  750. ; *********************************************************************
  751.  
  752.  
  753. make "action-window [
  754.    procedure [ [ ] [ ] [ :cw-tool-names :cw-sy :cw-c :cw-x :cw-y :cw-i ] ]
  755.    if memberp :tg-action-window windowlist
  756.    [  ( intuition 11 :tg-action-window )
  757.       stop ] [ ]
  758.    make "cw-tool-names gprop "tg-data "action-tool-names
  759.    make "cw-c count :cw-tool-names
  760.    make "cw-sy + 17 * 10 :cw-c
  761.    make "cw-x - gprop "tg-data "width 88
  762.    make "cw-y ( -    gprop "tg-data "height
  763.                      :cw-sy
  764.                      if <= 400 gprop "tg-data "height 
  765.                      [  + 19 * 10 count gprop "tg-data "mouse-tool-names ]
  766.                      [ 0 ] )
  767.    make "tg-action-window ( openwindow   :tg-screen
  768.                                           7
  769.                                           [ Action ]
  770.                                           :cw-x :cw-y
  771.                                           88 :cw-sy )
  772.    attach-menus :tg-action-window
  773.  
  774.    setpen :tg-action-window 1
  775.    make "cw-i 20
  776.    repeat :cw-c
  777.    [  move :tg-action-window 12 :cw-i
  778.       text :tg-action-window first :cw-tool-names
  779.       make "cw-tool-names bf :cw-tool-names
  780.       make "cw-i + 10 :cw-i ]
  781.  
  782.    setpen :tg-action-window 30
  783.    make "cw-i 12
  784.    repeat :cw-c
  785.    [  drawbox :tg-action-window 7 :cw-i 73 10
  786.       make "cw-i + 10 :cw-i ] ]
  787.  
  788.  
  789. make "click-action-window [
  790.    procedure [ [ :caw-x :caw-y ] [ ]
  791.                [ :caw-md :caw-tools :caw-tc :caw-tn
  792.                  :caw-hit :caw-hit2 :caw-yn ] ]
  793.    make "caw-tools gprop "tg-data "action-tools
  794.    make "caw-tc count :caw-tools
  795.    make "caw-tn int / - :caw-y 4 10
  796.    if ( and >>= 1 :caw-tc :caw-tn >> 7 81 :caw-x )
  797.    [  setpen :tg-action-window 31
  798.       drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10
  799.       make "caw-hit true
  800.       make "caw-hit2 true
  801.       while [  make "caw-md mouse :tg-action-window
  802.                = 1 item 3 :caw-md ]
  803.       [  make "caw-x first :caw-md
  804.          make "caw-yn int / - item 2 :caw-md 4 10
  805.          make "caw-hit and = :caw-yn :caw-tn >> 7 81 :caw-x
  806.          if = :caw-hit :caw-hit2 [ ]
  807.          [  setpen :tg-action-window if :caw-hit [ 31 ] [ 30 ]
  808.             drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10
  809.             make "caw-hit2 :caw-hit ] ]
  810.       if :caw-hit [ switch :caw-tn :caw-tools ] [ ]
  811.       setpen :tg-action-window 30
  812.       drawbox :tg-action-window 7 + 2 * 10 :caw-tn 73 10 ] [ ] ]
  813.  
  814.  
  815. make "action-tool [
  816.    procedure [ [ :at-item ] ]
  817.    switch :at-item gprop "tg-data "action-tools ]
  818.  
  819.  
  820. make "addaction [
  821.    procedure [ [ :aa-tool-name :aa-tool ] [ ]
  822.                [ :aa-tool-names :aa-tools :aa-open ] ]
  823.    make "aa-tool-names gprop "tg-data "action-tool-names
  824.    make "aa-tools gprop "tg-data "action-tools
  825.    if memberp :aa-tool-name :aa-tool-names [ ]
  826.    [  make "aa-open false
  827.       if namep "tg-action-window
  828.       [  if memberp :tg-action-window windowlist
  829.          [  make "aa-open true
  830.             closewindow :tg-action-window ] [ ] ] [ ]
  831.       pprop "tg-data "action-tool-names lput :aa-tool-name :aa-tool-names
  832.       pprop "tg-data "action-tools lput :aa-tool :aa-tools
  833.       repitem     15
  834.                   :tg-menu
  835.                   lput     se    [ ]
  836.                                  word  "\ 
  837.                                        :aa-tool-name
  838.                            item 15 :tg-menu
  839.       if memberp :tg-window windowlist [ reset-menus ] [ ]
  840.       if :aa-open [ action-window ] [ ] ] ]
  841.  
  842. addaction "Home [ home ]
  843. addaction "Clean [ clean ]
  844. addaction "Clear [ home clean ]
  845.  
  846. addaction "HogMem [
  847.    if emptyp gprop "tg-data "unhogmem
  848.       [ pprop "tg-data "unhogmem system 1 ] [ ]
  849.    ( system 2 gprop "tg-data "hogmem )
  850.    ( recycle 1 ) ]
  851.  
  852. addaction "UnHogMem [
  853.    if emptyp gprop "tg-data "unhogmem [ ]
  854.    [  ( system 2 gprop "tg-data "unhogmem )
  855.       pprop "tg-data "unhogmem [ ]
  856.       recycle
  857.       ( recycle 1 ) ] ]
  858.  
  859. addaction "Recycle [ ( recycle 1 ) ]
  860.  
  861.  
  862. make "playback [
  863.    procedure [ [ :pb-size :pb-rec ] [ ]
  864.                [  :pb-scale :pb-rh :pb-rs :pb-down
  865.                   :pb-sin :pb-cos :pb-tx :pb-ty
  866.                   :pb-x :pb-y :pb-fx :pb-fy :pb-ep :pb-t ] ]
  867.    if > 4 count :pb-rec [ stop ] [ ]
  868.    make "pb-down downp :tg-turtle
  869.    pu
  870.    fd :pb-size
  871.    make "pb-ep tpos :tg-turtle
  872.    bk :pb-size
  873.    make "pb-rec reverse :pb-rec
  874.    make "pb-scale / :pb-size first :pb-rec
  875.    make "pb-rec bf :pb-rec
  876.    make "pb-sin sin - heading :tg-turtle first :pb-rec
  877.    make "pb-cos cos - heading :tg-turtle first :pb-rec
  878.    make "pb-rec bf :pb-rec
  879.    make "pb-fx first first :pb-rec
  880.    make "pb-fy item 2 first :pb-rec
  881.    make "pb-x first tpos :tg-turtle
  882.    make "pb-y first bf tpos :tg-turtle
  883.    make "pb-rec bf :pb-rec
  884.    make "pb-t first :pb-rec
  885.    make "pb-tx - first :pb-t :pb-fx
  886.    make "pb-ty - item 2 :pb-t :pb-fy
  887.    settpos list   +  :pb-x
  888.                      *  :pb-scale
  889.                         +  * :pb-tx :pb-cos
  890.                            * :pb-ty :pb-sin
  891.                   +  :pb-y
  892.                      *  :pb-scale
  893.                         +  * :pb-ty :pb-cos
  894.                            * +- :pb-tx :pb-sin
  895.    make "pb-rec bf :pb-rec
  896.    pd
  897.    while [ not emptyp :pb-rec ]
  898.    [  make "pb-t first :pb-rec
  899.       make "pb-tx - first :pb-t :pb-fx
  900.       make "pb-ty - item 2 :pb-t :pb-fy
  901.       settpos list   +  :pb-x
  902.                         *  :pb-scale
  903.                            +  * :pb-tx :pb-cos
  904.                               * :pb-ty :pb-sin
  905.                      +  :pb-y
  906.                         *  :pb-scale
  907.                            +  * :pb-ty :pb-cos
  908.                               * +- :pb-tx :pb-sin
  909.       make "pb-rec bf :pb-rec ]
  910.    pu
  911.    settpos :pb-ep
  912.    if :pb-down [ pd ] [ ] ]
  913.  
  914.  
  915. make "record [
  916.    procedure [ ]
  917.    output gprop "tg-data "mouse-record ]
  918.  
  919. addaction "PlayBack [ playback :size record ]
  920.  
  921. addaction "MarkPos [ fd :size bk :size ]
  922.  
  923.  
  924. addaction "Text [
  925.    pr [ Enter Text ]
  926.    type ">>
  927.    ( intuition 12 @0 )
  928.    text :tg-window rl ]
  929.  
  930.  
  931. make "poly [
  932.    procedure [ [ :p-size :p-sides ] [ ] [ :a ] ]
  933.    make "a / 360 :p-sides
  934.    repeat :p-sides [ fd :p-size rt :a ] ]
  935.  
  936. make "circle [
  937.    procedure [ [ :c-size ] [ ] ]
  938.    if downp :tg-turtle
  939.    [  pu
  940.       fd :c-size
  941.       rt 91
  942.       pd
  943.       poly * :c-size 0.034906785 180
  944.       pu
  945.       lt 91
  946.       bk :c-size
  947.       pd ] [ ] ]
  948.  
  949. addaction "Circle [ circle :size ]
  950.  
  951.  
  952. ; addaction "TriAngle [ poly :size 3 ]
  953. ; addaction "Square [ poly :size 4 ]
  954. ; addaction "Pentagon [ poly :size 5 ]
  955. ; addaction "Hexagon [ poly :size 6 ]
  956.  
  957. addaction "Star\ 5 [ repeat 5 [ fd :size rt 144 ] ]
  958.  
  959.  
  960. ; *********************************************************************
  961. ; *** Palette Tool
  962. ; *********************************************************************
  963.  
  964.  
  965. make "palette-window [
  966.    procedure [ ]
  967.    if ( palettep :tg-palette-window )
  968.    [  ( intuition 11 :tg-palette-window ) ]
  969.    [  make "tg-palette-window openpalette true :tg-screen
  970.       attach-menus :tg-palette-window ] ]
  971.  
  972.  
  973. ; *********************************************************************
  974. ; *** Subs
  975. ; *********************************************************************
  976.  
  977.  
  978. make "pattern [
  979.    procedure [ [ :p-pn ] [ ] [ :p-pat ] ]
  980.    make "p-pat item :p-pn [
  981.          xxxxxxxxxxxxxxxx
  982.          xxxxxxxx--------
  983.          xxxx----xxxx----
  984.          xx--xx--xx--xx--
  985.          x-x-x-x-x-x-x-x-
  986.          x---x---x---x---
  987.          x-------x-------
  988.          -xxx-xxx-xxx-xxx
  989.          -xxxxxxx-xxxxxxx
  990.          x---------------
  991.          xx--------------
  992.          xxxx------------
  993.          xxxxxxxxxxxx----
  994.          -------xxx---xxx
  995.          xxxxxxx---xxx--- ]
  996.    settlp :p-pat
  997.    setlinept :tg-window :p-pat
  998.    movechecks 2 3 gprop "tg-data "pattern :p-pn
  999.    pprop "tg-data "pattern :p-pn ]
  1000.  
  1001.  
  1002. make "setghosts [
  1003.    procedure [ [ :sg-window ] ]
  1004.    if or = 1 gprop "tg-data "modes
  1005.          = 3 gprop "tg-data "modes
  1006.    [  ( intuition 3 :sg-window 2 8 5 )
  1007.       ( intuition 3 :sg-window 2 8 6 ) ] [ ]
  1008.    if >= gprop "tg-data "depth 5
  1009.    [  ( intuition 3 :sg-window 2 9 2 )
  1010.       ( intuition 3 :sg-window 2 9 4 ) ] [ ] ]
  1011.  
  1012.  
  1013. ;  ***  added to disable "setghosts" for AGA  ***
  1014. make "setghosts [
  1015.    procedure [ [ :sg-window ] ] ]
  1016.  
  1017.  
  1018. make "setchecks [
  1019.    procedure [ [ :sc-window ] ]
  1020.    ( intuition 13 :sc-window 2 3 gprop "tg-data "pattern )
  1021.    ( intuition 13 :sc-window 2 6 if downp :tg-turtle [ 2 ] [ 1 ] )
  1022.    ( intuition 13 :sc-window 2 6 + 2 gprop "tg-data "drawmode )
  1023.    ( intuition 13 :sc-window 2 4 gprop "tg-data "mouse-tool-number )
  1024.    ( intuition 13 :sc-window 2 8 gprop "tg-data "depth )
  1025.    ( intuition 13 :sc-window 2 9 + 1 gprop "tg-data "modes ) ]
  1026.  
  1027.  
  1028. make "reset-menus [
  1029.    procedure [ ]
  1030.    attach-menus @0
  1031.    attach-menus :tg-window
  1032.    attach-menus :tg-color-window
  1033.    attach-menus :tg-palette-window
  1034.    attach-menus :tg-mouse-window
  1035.    attach-menus :tg-action-window ]
  1036.  
  1037.  
  1038. make "attach-menus [
  1039.    procedure [ [ :am-window ] ]
  1040.    if ( or  memberp :am-window windowlist
  1041.             = @0 :am-window ( palettep :am-window ) )
  1042.    [  setmenu :am-window :tg-menu
  1043.       setchecks :am-window
  1044.       setghosts :am-window ] [ ] ]
  1045.  
  1046.  
  1047. make "movechecks [
  1048.    procedure [ [ :mc-m :mc-i :mc-fs :mc-ts ] ]
  1049.    movecheck @0                  :mc-m :mc-i :mc-fs :mc-ts
  1050.    movecheck :tg-window          :mc-m :mc-i :mc-fs :mc-ts
  1051.    movecheck :tg-color-window    :mc-m :mc-i :mc-fs :mc-ts
  1052.    movecheck :tg-palette-window  :mc-m :mc-i :mc-fs :mc-ts
  1053.    movecheck :tg-mouse-window    :mc-m :mc-i :mc-fs :mc-ts
  1054.    movecheck :tg-action-window   :mc-m :mc-i :mc-fs :mc-ts ]
  1055.  
  1056.  
  1057. make "movecheck [
  1058.    procedure [ [ :mc-window :mc-m :mc-i :mc-fs :mc-ts ] ]
  1059.    if ( or    memberp :mc-window windowlist
  1060.               = @0 :mc-window ( palettep :mc-window ) )
  1061.    [  ( intuition 14 :mc-window :mc-m :mc-i :mc-fs )
  1062.       ( intuition 13 :mc-window :mc-m :mc-i :mc-ts ) ] [ ] ]
  1063.  
  1064.  
  1065. make "drawbox [
  1066.    procedure [ [ :db-window :db-le :db-te :db-w :db-h ] ]
  1067.    move :db-window :db-le :db-te
  1068.    draw :db-window + :db-le :db-w :db-te
  1069.    draw :db-window + :db-le :db-w + :db-te :db-h
  1070.    draw :db-window :db-le + :db-te :db-h
  1071.    draw :db-window :db-le :db-te ]
  1072.  
  1073.  
  1074. ; *********************************************************************
  1075. ; *** Screen and Windows
  1076. ; *********************************************************************
  1077.  
  1078. ;  clear text
  1079.  
  1080. make "ct [ procedure [ ] cleartext ]
  1081.  
  1082. ;  clear screen
  1083.  
  1084. make "cs [ procedure [ ] home clean ]
  1085.  
  1086. ;  full screen
  1087.  
  1088. make "fs [ procedure [ ] ( intuition 11 :tg-window ) ]
  1089.  
  1090. ;  text screen
  1091.  
  1092. make "ts [ procedure [ ]
  1093.    ( intuition 12 @0 )
  1094.    ( intuition 11 @0 )
  1095.    ( intuition 2 @0 0 0 )
  1096.    wait 0.1
  1097.    ( intuition 8 @0 gprop "tg-data "width gprop "tg-data "height ) ]
  1098.  
  1099.  
  1100. ;  split screen
  1101.  
  1102. make "ss [
  1103.    procedure [ [ ] [ ] [ :ss-w :ss-h :ss-sx :ss-sy ] ]
  1104.    make "ss-w gprop "tg-data "width
  1105.    make "ss-h gprop "tg-data "height
  1106.    make "ss-sx if <= 640 :ss-w [ - :ss-w 292 ] [ :ss-w ]
  1107.    make "ss-sy if <= 400 :ss-h [ 54 ] [ 46 ]
  1108.    ( intuition 12 @0 )
  1109.    ( intuition 11 @0 )
  1110.    ( intuition 10 :tg-window )
  1111.    ( intuition 8 @0 :ss-sx :ss-sy )
  1112.    wait 0.1
  1113.    ( intuition 2 @0 0 - :ss-h :ss-sy ) ]
  1114.  
  1115.  
  1116. ; *********************************************************************
  1117.  
  1118. bury :turtle-names
  1119.  
  1120.  
  1121.